home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / defcombin.lsp < prev    next >
Lisp/Scheme  |  1992-08-21  |  16KB  |  452 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; DEFINE-METHOD-COMBINATION
  32. ;;;
  33.  
  34. (defmacro define-method-combination (&whole form &rest args)
  35.   (declare (ignore args))
  36.   (if (and (cddr form)
  37.        (listp (caddr form)))
  38.       (expand-long-defcombin form)
  39.       (expand-short-defcombin form)))
  40.  
  41.  
  42. ;;;
  43. ;;; STANDARD method combination
  44. ;;;
  45. ;;; The STANDARD method combination type is implemented directly by the class
  46. ;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
  47. ;;; standard method combination directly and is defined by hand in the file
  48. ;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
  49. ;;; file for bootstrapping reasons.
  50. ;;;
  51. ;;; A commented out copy of this definition appears in combin.lisp.
  52. ;;; If you change this definition here, be sure to change it there
  53. ;;; also.
  54. ;;;
  55. (defmethod find-method-combination ((generic-function generic-function)
  56.                     (type (eql 'standard))
  57.                     options)
  58.   (when options
  59.     (method-combination-error
  60.       "The method combination type STANDARD accepts no options."))
  61.   *standard-method-combination*)
  62.  
  63.  
  64.  
  65. ;;;
  66. ;;; short method combinations
  67. ;;;
  68. ;;; Short method combinations all follow the same rule for computing the
  69. ;;; effective method.  So, we just implement that rule once.  Each short
  70. ;;; method combination object just reads the parameters out of the object
  71. ;;; and runs the same rule.
  72. ;;;
  73. ;;;
  74. (defclass short-method-combination (standard-method-combination)
  75.      ((operator
  76.     :reader short-combination-operator
  77.     :initarg :operator)
  78.       (identity-with-one-argument
  79.     :reader short-combination-identity-with-one-argument
  80.     :initarg :identity-with-one-argument))
  81.   (:predicate-name short-method-combination-p))
  82.  
  83. (defun expand-short-defcombin (whole)
  84.   (let* ((type (cadr whole))
  85.      (documentation
  86.        (getf (cddr whole) :documentation ""))
  87.      (identity-with-one-arg
  88.        (getf (cddr whole) :identity-with-one-argument nil))
  89.      (operator 
  90.        (getf (cddr whole) :operator type)))
  91.     (make-top-level-form `(define-method-combination ,type)
  92.              '(load eval)
  93.       `(load-short-defcombin
  94.      ',type ',operator ',identity-with-one-arg ',documentation))))
  95.  
  96. (defun load-short-defcombin (type operator ioa doc)
  97.   (let* ((truename (load-truename))
  98.      (specializers
  99.        (list (find-class 'generic-function)
  100.          (intern-eql-specializer type)
  101.          *the-class-t*))
  102.      (old-method
  103.        (get-method #'find-method-combination () specializers nil))
  104.      (new-method nil))
  105.     (setq new-method
  106.       (make-instance 'standard-method
  107.         :qualifiers ()
  108.         :specializers specializers
  109.         :lambda-list '(generic-function type options)
  110.             :function
  111.                 #'(lambda (args next-methods)
  112.                     (declare (ignore next-methods))
  113.                     (apply #'(lambda (gf type options)
  114.                        (declare (ignore gf))
  115.                          (do-short-method-combination
  116.                            type options operator ioa new-method doc))
  117.                            args))
  118.         :optimized-function
  119.                 #'(lambda (gf type options)
  120.             (declare (ignore gf))
  121.               (do-short-method-combination
  122.                 type options operator ioa new-method doc))
  123.         :definition-source `((define-method-combination ,type) ,truename)))
  124.     (when old-method
  125.       (remove-method #'find-method-combination old-method))
  126.     (add-method #'find-method-combination new-method)))
  127.  
  128. (defun do-short-method-combination (type options operator ioa method doc)
  129.   (cond ((null options) (setq options '(:most-specific-first)))
  130.     ((equal options '(:most-specific-first)))
  131.     ((equal options '(:most-specific-last)))
  132.     (t
  133.      (method-combination-error
  134.        "Illegal options to a short method combination type.~%~
  135.             The method combination type ~S accepts one option which~%~
  136.             must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
  137.        type)))
  138.   (make-instance 'short-method-combination
  139.          :type type
  140.          :options options
  141.          :operator operator
  142.          :identity-with-one-argument ioa
  143.          :definition-source method
  144.          :documentation doc))
  145.  
  146. (defmethod compute-effective-method ((generic-function generic-function)
  147.                      (combin short-method-combination)
  148.                      applicable-methods)
  149.   (let ((type (method-combination-type combin))
  150.     (operator (short-combination-operator combin))
  151.     (ioa (short-combination-identity-with-one-argument combin))
  152.     (around ())
  153.     (primary ()))
  154.     (dolist (m applicable-methods)
  155.       (let ((qualifiers (method-qualifiers m)))
  156.     (flet ((lose (method why)
  157.          (invalid-method-error
  158.            method
  159.            "The method ~S ~A.~%~
  160.                     The method combination type ~S was defined with the~%~
  161.                     short form of DEFINE-METHOD-COMBINATION and so requires~%~
  162.                     all methods have either the single qualifier ~S or the~%~
  163.                     single qualifier :AROUND."
  164.            method why type type)))
  165.       (cond ((null qualifiers)
  166.          (lose m "has no qualifiers"))
  167.         ((cdr qualifiers)
  168.          (lose m "has more than one qualifier"))
  169.         ((eq (car qualifiers) :around)
  170.          (push m around))
  171.         ((eq (car qualifiers) type)
  172.          (push m primary))
  173.         (t
  174.          (lose m "has an illegal qualifier"))))))
  175.     (setq around (nreverse around))
  176.     (unless (memq :most-specific-last (method-combination-options combin))
  177.       (setq primary (nreverse primary)))
  178.     (let ((main-method
  179.         (if (and (null (cdr primary))
  180.              (not (null ioa)))
  181.         `(call-method ,(car primary) ())
  182.         `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
  183.                       primary)))))
  184.       (cond ((null primary)
  185.          `(error "No ~S methods for the generic function ~S."
  186.              ',type ',generic-function))
  187.         ((null around) main-method)
  188.         (t
  189.          `(call-method ,(car around)
  190.                (,@(cdr around) (make-method ,main-method))))))))
  191.  
  192.  
  193. ;;;
  194. ;;; long method combinations
  195. ;;;
  196. ;;;
  197.  
  198. (defclass long-method-combination (standard-method-combination)
  199.      ((function :initarg :function
  200.         :reader long-method-combination-function)))
  201.  
  202. (defun expand-long-defcombin (form)
  203.   (let ((type (cadr form))
  204.     (lambda-list (caddr form))
  205.     (method-group-specifiers (cadddr form))
  206.     (body (cddddr form))
  207.     (arguments-option ())
  208.     (gf-var nil))
  209.     (when (and (consp (car body)) (eq (caar body) :arguments))
  210.       (setq arguments-option (cdr (pop body))))
  211.     (when (and (consp (car body)) (eq (caar body) :generic-function))
  212.       (setq gf-var (cadr (pop body))))
  213.     (multiple-value-bind (documentation function)
  214.     (make-long-method-combination-function
  215.       type lambda-list method-group-specifiers arguments-option gf-var
  216.       body)
  217.       (make-top-level-form `(define-method-combination ,type)
  218.                '(load eval)
  219.     `(load-long-defcombin ',type ',documentation #',function)))))
  220.  
  221. (defvar *long-method-combination-functions* (make-hash-table :test #'eq))
  222.  
  223. (defun load-long-defcombin (type doc function)
  224.   (let* ((specializers
  225.        (list (find-class 'generic-function)
  226.          (intern-eql-specializer type)
  227.          *the-class-